home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / parser-macros.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  11.2 KB  |  328 lines  |  [TEXT/CCL2]
  1. ;;; Macro definitions for the parser & lexer.
  2.  
  3.  
  4. ;;; This macro allows debugging of the lexer.  Before releasing, this can
  5. ;;; be replaced by (begin ,@body) for faster code.
  6.  
  7. (define-syntax (trace-parser tag . body)
  8. ;  `(begin 
  9. ;     (let* ((k (tracing-parse/entry ',tag))
  10. ;        (res (begin ,@body)))
  11. ;       (tracing-parse/exit ',tag k res)
  12. ;       res))
  13.   (declare (ignore tag))
  14.   `(begin ,@body)
  15.   )
  16.  
  17. ;;; Macros used by the lexer.
  18.  
  19. ;;; The lexer used a macro, char-case, to dispatch on the syntactic catagory of
  20. ;;; a character.  These catagories (processed at compile time) are defined
  21. ;;; here.  Note that some of these definitions use the char-code
  22. ;;; directly and would need updating for different character sets.
  23.  
  24. (define *lex-definitions*
  25.   '((vtab 11)  ; define by ascii code to avoid relying of the reader
  26.     (formfeed 12) 
  27.     (whitechar #\newline #\space #\tab formfeed vtab)
  28.     (small #\a - #\z)
  29.     (large #\A - #\Z)
  30.     (digit #\0 - #\9)
  31.     (symbol #\! #\# #\$ #\% #\& #\* #\+ #\. #\/ #\< #\= #\> #\? #\@
  32.       #\\ #\^ #\|)
  33.     (presymbol #\- #\~)
  34.     (exponent #\e #\E)
  35.     (graphic large small digit
  36.              #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+
  37.              #\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@
  38.          #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~)
  39.     (charesc #\a #\b #\f #\n #\r #\t #\v #\\ #\" #\' #\&)
  40.     (cntrl large #\@ #\[ #\\ #\] #\^ #\_)))
  41.  
  42. ;;; The char-case macro is similar to case using characters to select.
  43. ;;; The following capabilities are added by char-case:
  44. ;;;   pre-defined constants are denoted by symbols (defined above)
  45. ;;;   ranges of characters are represented using -.  For example,
  46. ;;;     (#\a - #\z #\A - #\Z) denotes all alphabetics.
  47. ;;;   numbers refer to the char code of a character.
  48. ;;; The generated code is optimized somewhat to take advantage of
  49. ;;; consecutive character ranges.  With a little work, this could be
  50. ;;; implemented using jump tables someday.
  51.  
  52. (define-syntax (char-case exp . alts)
  53.   (expand-char-case exp alts))
  54.  
  55. (define (expand-char-case exp alts)
  56.   (let ((temp (gensym)))
  57.     `(let ((,temp ,exp))
  58.        ,(expand-char-case1 temp alts))))
  59.  
  60. (define (expand-char-case1 temp alts)
  61.   (if (null? alts)
  62.       '()
  63.       (let* ((alt (car alts))
  64.          (test (car alt))
  65.          (body (cons 'begin (cdr alt)))
  66.          (rest (expand-char-case1 temp (cdr alts))))
  67.     (cond ((eq? test 'else)
  68.            body)
  69.           (else
  70.            `(if (or ,@(gen-char-tests temp
  71.                  (if (pair? test) test (list test))))
  72.             ,body
  73.             ,rest))))))
  74.  
  75. (define (gen-char-tests temp tests)
  76.   (gen-char-tests-1 temp
  77.     (sort-list (gather-char-tests tests) (function char<?))))
  78.  
  79. (define (gen-char-tests-1 temp chars)
  80.   (cond ((null? chars)
  81.      '())
  82.     ((long-enough-run? chars 3)
  83.      (gen-range-check temp (car chars) (car chars) (cdr chars)))
  84.     (else
  85.      `((char=? ,temp ',(car chars))
  86.        ,@(gen-char-tests-1 temp (cdr chars))))))
  87.  
  88. (define (gen-range-check temp first current chars)
  89.   (if (and (pair? chars) (consec-chars? current (car chars)))
  90.       (gen-range-check temp first (car chars) (cdr chars))
  91.       `((and (char>=? ,temp ',first)
  92.          (char<=? ,temp ',current))
  93.     ,@(gen-char-tests-1 temp chars))))
  94.  
  95. (define (consec-chars? c1 c2)
  96.   (eqv? (+ 1 (char->integer c1)) (char->integer c2)))
  97.  
  98. (define (long-enough-run? l n)
  99.   (or (eqv? n 1)
  100.       (and (pair? (cdr l))
  101.        (consec-chars? (car l) (cadr l))
  102.        (long-enough-run? (cdr l) (1- n)))))
  103.  
  104. (define (gather-char-tests tests)
  105.   (cond ((null? tests)
  106.      '())
  107.     ((symbol? (car tests))
  108.      (let ((new-test (assq (car tests) *lex-definitions*)))
  109.        (if new-test
  110.            (gather-char-tests (append (cdr new-test) (cdr tests)))
  111.            (error "Unknown character class: ~A~%" (car tests)))))
  112.     ((integer? (car tests))
  113.      (cons (integer->char (car tests))
  114.            (gather-char-tests (cdr tests))))
  115.     ((and (pair? (cdr tests)) (eq? '- (cadr tests)))
  116.      (letrec ((fn (lambda (a z)
  117.             (if (char>? a z)
  118.                 (gather-char-tests (cdddr tests))
  119.                 (cons a (funcall
  120.                       fn (integer->char
  121.                      (+ 1 (char->integer a))) z))))))
  122.        (funcall fn (car tests) (caddr tests))))
  123.     ((char? (car tests))
  124.      (cons (car tests) (gather-char-tests (cdr tests))))
  125.     (else
  126.      (error "Invalid selector in char-case: ~A~%" (car tests)))))
  127.  
  128. ;;; This macro scans a list of characters on a given syntaxtic catagory.
  129. ;;; The current character is always included in the resulting list.
  130.  
  131. (define-syntax (scan-list-of char-type)
  132.  `(letrec ((test-next (lambda ()
  133.                (char-case *char*
  134.             (,char-type
  135.              (let ((c *char*))
  136.                (advance-char)
  137.                (cons c (funcall test-next))))
  138.             (else '())))))
  139.     (let ((c *char*))
  140.       (advance-char)
  141.       (cons c (funcall test-next)))))
  142.  
  143. ;;; This macro tests for string equality in which the strings are
  144. ;;; represented by lists of characters.  The comparisons are expanded
  145. ;;; inline (really just a little partial evaluation going on here!) for
  146. ;;; fast execution.  The tok argument evaluate to a list of chars.  The string
  147. ;;; argument must be a string constant, which is converted to characters
  148. ;;; as the macro expands.
  149.  
  150. (define-syntax (string=/list? tok string)
  151.   (let ((temp (gensym)))
  152.     `(let ((,temp ,tok))
  153.        ,(expand-string=/list? temp (string->list string)))))
  154.  
  155. (define (expand-string=/list? var chars)
  156.   (if (null? chars)
  157.       `(null? ,var)
  158.       (let ((new-temp (gensym)))
  159.     `(and (pair? ,var)
  160.           (char=? (car ,var) ',(car chars))
  161.           (let ((,new-temp (cdr ,var)))
  162.         ,(expand-string=/list? new-temp (cdr chars)))))))
  163.  
  164. ;;; This macro extends the string equality defined above to search a
  165. ;;; list of reserved words quickly for keywords.  It does this by a case
  166. ;;; dispatch on the first character of the string and then processing
  167. ;;; the remaining characters wirh string=/list.  This would go a little
  168. ;;; faster with recursive char-case statements, but I'm a little too
  169. ;;; lazy at for this at the moment.  If a keyword is found is emitted
  170. ;;; as a symbol.  If not, the token string is emitted with the token
  171. ;;; type indicated.  Assume the string being scanned is a list of
  172. ;;; chars assigned to a var.  (Yeah - I know - I should add a gensym
  173. ;;; var for this argument!!).
  174.  
  175. (define-syntax (parse-reserved var token-type . reserved-words)
  176.  (let ((sorted-rws (sort-list reserved-words (function string<?))))
  177.   `(let ((thunk (lambda () (emit-token/string ',token-type ,var))))
  178.     (char-case (car ,var)
  179.      ,@(expand-parse-reserved var
  180.         (group-by-first-char (list (car sorted-rws)) (cdr sorted-rws)))
  181.       (else (funcall thunk))))))
  182.  
  183. (define (group-by-first-char group rest)
  184.   (cond ((null? rest)
  185.      (list group))
  186.     ((char=? (string-ref (car group) 0)
  187.          (string-ref (car rest) 0))
  188.      (group-by-first-char (append group (list (car rest))) (cdr rest)))
  189.     (else
  190.      (cons group (group-by-first-char (list (car rest)) (cdr rest))))))
  191.  
  192. (define (expand-parse-reserved var groups)
  193.   (if (null? groups)
  194.       '()
  195.       `((,(string-ref (caar groups) 0)
  196.      (cond ,@(expand-parse-reserved/group var (car groups))
  197.            (else (funcall thunk))))
  198.     ,@(expand-parse-reserved var (cdr groups)))))
  199.  
  200. (define (expand-parse-reserved/group var group)
  201.   (if (null? group)
  202.       '()
  203.       `(((string=/list? (cdr ,var)
  204.          ,(substring (car group) 1 (string-length (car group))))
  205.      (emit-token ',(string->symbol (car group))))
  206.     ,@(expand-parse-reserved/group var (cdr group)))))
  207.  
  208.  
  209. ;;; The following macros are used by the parser.
  210.  
  211. ;;; The primary macro used by the parser is token-case, which dispatches
  212. ;;; on the type of the current token (this is always *token* - unlike the
  213. ;;; lexer, no lookahead is provided; however, some of these dispatches are
  214. ;;; procedures that do a limited lookahead.  The problem with lookahead is that
  215. ;;; the layout rule adds tokens which are not visible looking into the
  216. ;;; token stream directly.
  217.  
  218. ;;; Unlike char-case, the token is normally advanced unless the selector
  219. ;;; includes `no-advance'.  The final else also avoids advancing the token.
  220.  
  221. ;;; In addition to raw token types, more complex types can be used.  These
  222. ;;; are defined here.  The construct `satisfies fn' calls the indicated
  223. ;;; function to determine whether the current token matches.
  224.  
  225. ;;; If the token type to be matched is not a constant, the construct
  226. ;;; `unquote var' matches the current token against the type in the var.
  227.  
  228. (define *predefined-syntactic-catagories* '(
  229.   (+ satisfies at-varsym/+?)
  230.   (- satisfies at-varsym/-?)
  231.   (tycon no-advance conid)
  232.   (tyvar no-advance varid)
  233.   (var no-advance varid satisfies at-varsym/paren?)
  234.   (con no-advance conid satisfies at-consym/paren?)
  235.   (name no-advance var con)
  236.   (consym/paren no-advance satisfies at-consym/paren?)
  237.   (varsym? no-advance varsym)
  238.   (consym? no-advance consym)
  239.   (varid? no-advance varid)
  240.   (conid? no-advance conid)
  241.   (op no-advance varsym consym \`)
  242.   (varop no-advance varsym satisfies at-varid/quoted?)
  243.   (conop no-advance consym satisfies at-conid/quoted?)
  244.   (modid no-advance conid)
  245.   (literal no-advance integer float char string)
  246.   (numeric no-advance integer float)
  247.   (k no-advance integer)
  248.   (+k no-advance satisfies at-+k?)
  249.   (-n no-advance satisfies at--n?)
  250.   (apat-start no-advance varid conid literal _ \( \[ \~)
  251.   (pat-start no-advance - apat-start)
  252.   (atype-start no-advance tycon tyvar \( \[)
  253.   (aexp-start no-advance varid conid \( \[ literal _)
  254.   ))
  255.  
  256. ;;; The format of token-case is
  257. ;;;  (token-case
  258. ;;;    (sel1 . e1) (sel2 . e2) ... [(else . en)])
  259. ;;; If the sel is a symbol it is the same as a singleton list: (@ x) = ((@) x)
  260.  
  261. ;;; Warning: this generates rather poor code!  Should be fixed up someday.
  262.  
  263. (define-syntax (token-case . alts)
  264.   `(cond ,@(map (function gen-token-case-alt) alts)))
  265.  
  266. (define (gen-token-case-alt alt)
  267.   (let ((test (car alt))
  268.     (code (cdr alt)))
  269.     (cond ((eq? test 'else)
  270.        `(else ,@code))
  271.       ((symbol? test)
  272.        (gen-token-case-alt-1 (expand-catagories (list test)) code))
  273.       (else
  274.        (gen-token-case-alt-1 (expand-catagories test) code)))))
  275.  
  276. (define (expand-catagories terms)
  277.   (if (null? terms)
  278.       terms
  279.       (let ((a (assq (car terms) *predefined-syntactic-catagories*))
  280.         (r (expand-catagories (cdr terms))))
  281.     (if (null? a)
  282.         (cons (car terms) r)
  283.         (expand-catagories (append (cdr a) r))))))
  284.  
  285. (define (gen-token-case-alt-1 test code)
  286.   `((or ,@(gen-token-test test))
  287.     ,@(if (memq 'no-advance test) '() '((advance-token)))
  288.     ,@code))
  289.  
  290. (define (gen-token-test test)
  291.   (cond ((null? test)
  292.      '())
  293.     ((eq? (car test) 'no-advance)
  294.      (gen-token-test (cdr test)))
  295.     ((eq? (car test) 'unquote)
  296.      (cons `(eq? *token* ,(cadr test)) (gen-token-test (cddr test))))
  297.     ((eq? (car test) 'satisfies)
  298.      (cons (list (cadr test)) (gen-token-test (cddr test))))
  299.     (else
  300.      (cons `(eq? *token* ',(car test)) (gen-token-test (cdr test))))))
  301.  
  302. ;;; require-tok requires a specific token to be at the scanner.  If it
  303. ;;; is found, the token is advanced over.  Otherwise, the error
  304. ;;; routine is called.
  305.  
  306. (define-syntax (require-token tok error-handler)
  307.   `(token-case
  308.     (,tok '())
  309.     (else ,error-handler)))
  310.  
  311. ;;; The save-parser-context macro captures the current line & file and
  312. ;;; attaches it to the ast node generated.
  313.  
  314. (define-syntax (save-parser-context . body)
  315.   (let ((temp1 (gensym))
  316.     (temp2 (gensym)))
  317.     `(let ((,temp1 (capture-current-line))
  318.        (,temp2 (begin ,@body)))
  319.        (setf (ast-node-line-number ,temp2) ,temp1)
  320.        ,temp2)))
  321.  
  322. (define (capture-current-line)
  323.   (make source-pointer (line *current-line*) (file *current-file*)))
  324.  
  325. (define-syntax (push-decl-list decl place)
  326.   `(setf ,place (nconc ,place (list ,decl))))
  327.  
  328.